home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / vis082s.arc / GENSUBS.PAS < prev    next >
Pascal/Delphi Source File  |  1991-04-17  |  6KB  |  316 lines

  1. {$R-,S-,I-,D-,F+,V-,B-,N-,L+ }
  2.  
  3. unit gensubs;
  4.  
  5. interface
  6.  
  7. uses dos,gentypes,modem; {Isn't thiscool dude? Almost like smoking dope!}
  8.  
  9. function strr (n:integer):mstr;
  10. function streal (r:real):mstr;
  11. function strlong (l:longint):mstr;
  12. function valu (q:mstr):integer;
  13. function addrstr (p:pointer):sstr;
  14. procedure parse3 (s:lstr; var a,b,c:word);
  15. function packtime (var dt:datetime):longint;
  16.     { Replaces Turbo's procedural version }
  17. function now:longint;
  18. function timestr (time:longint):sstr;
  19. function timeval (q:sstr):longint;
  20. function timepart (time:longint):longint;
  21. function datestr (time:longint):sstr;
  22. function dateval (q:sstr):longint;
  23. function datepart (time:longint):longint;
  24. function upstring (s:anystr):anystr;
  25. function match (s1,s2:anystr):boolean;
  26. function devicename (name:lstr):boolean;
  27. function exist (n:lstr):boolean;
  28. procedure appendfile (name:lstr; var q:text);
  29. procedure addexitproc (p:pointer);
  30. procedure doneexitproc;
  31. function ratio(x1,x2:longint):integer;
  32.  
  33. implementation
  34.  
  35. const maxexitprocs=25;
  36.  
  37. var exitstack:array [1..maxexitprocs] of pointer;
  38.     exitstackptr:integer;
  39.  
  40. type packedtimerec=record
  41.        date,time:word
  42.      end;
  43.  
  44. function strr (n:integer):mstr;
  45. var q:mstr;
  46. begin
  47.   str (n,q);
  48.   strr:=q
  49. end;
  50.  
  51. function ratio(x1,x2:longint):integer;
  52. var x3:integer;
  53.         y1,y2,y3:real;
  54. Begin
  55.     if x1<1 then x1:=1;
  56.     if x2<1 then x2:=1;
  57.     y1:=int(x1);
  58.     y2:=int(x2);
  59.     y3:=y1/y2;
  60.     y3:=y3*100;
  61.     x3:=trunc(y3);
  62.     ratio:=x3;
  63. end;
  64. function streal (r:real):mstr;
  65. var q:mstr;
  66. begin
  67.   str (r:0:0,q);
  68.   streal:=q
  69. end;
  70.  
  71. function strlong (l:longint):mstr;
  72. var q:mstr;
  73. begin
  74.   str (l,q);
  75.   strlong:=q
  76. end;
  77.  
  78. function valu (q:mstr):integer;
  79. var i,s,pu:integer;
  80.     r:real;
  81.     c:Char;
  82. begin
  83.   valu:=0;
  84.   if length(q)=0 then exit;
  85.   c:=Q[1];
  86.   if not (C in ['0','1','2','3','4','5','6','7','8','9','-']) then begin
  87.     Valu:=0;
  88.     exit;
  89.   End;
  90.   If (c in ['A'..'~']) then Begin
  91.     Valu:=0;
  92.     Exit;
  93.   End;
  94.   if length(q)>5 then exit;
  95.   val (q,r,s);
  96.   if s<>0 then exit;
  97.   if (r<=32767.0) and (r>=-32767.0)
  98.     then valu:=round(r)
  99. end;
  100.  
  101. function addrstr (p:pointer):sstr;
  102.  
  103.   function hexstr (n:integer):sstr;
  104.  
  105.     function hexbytestr (b:byte):sstr;
  106.     const hexchars:array[0..15] of char='0123456789ABCDEF';
  107.     begin
  108.       hexbytestr:=hexchars[b shr 4]+hexchars[b and 15]
  109.     end;
  110.  
  111.   begin
  112.     hexstr:=hexbytestr (hi(n))+hexbytestr(lo(n))
  113.   end;
  114.  
  115. begin
  116.   addrstr:=hexstr(seg(p^))+':'+hexstr(ofs(p^))
  117. end;
  118.  
  119. procedure parse3 (s:lstr; var a,b,c:word);
  120. var p:integer;
  121.  
  122.   procedure parse1 (var n:word);
  123.   var ns:lstr;
  124.   begin
  125.     ns[0]:=#0;
  126.     while (p<=length(s)) and (s[p] in ['0'..'9']) do begin
  127.       ns:=ns+s[p];
  128.       p:=p+1
  129.     end;
  130.     if length(ns)=0
  131.       then n:=0
  132.       else n:=valu(ns);
  133.     if p<length(s) then p:=p+1
  134.   end;
  135.  
  136. begin
  137.   p:=1;
  138.   parse1 (a);
  139.   parse1 (b);
  140.   parse1 (c)
  141. end;
  142.  
  143. function packtime (var dt:datetime):longint;
  144. var l:longint;
  145. begin
  146.   dos.packtime (dt,l);
  147.   packtime:=l
  148. end;
  149.  
  150. function now:longint;
  151. var dt:datetime;
  152.     t:word;
  153.     l:longint;
  154. begin
  155.   gettime (dt.hour,dt.min,dt.sec,t);
  156.   getdate (dt.year,dt.month,dt.day,t);
  157.   l:=packtime (dt);
  158.   now:=l
  159. end;
  160.  
  161. function timestr (time:longint):sstr;
  162. var h1:integer;
  163.     ms:sstr;
  164.     dt:datetime;
  165. const ampmstr:array [false..true] of string[2]=('am','pm');
  166. begin
  167.   unpacktime (time,dt);
  168.   h1:=dt.hour;
  169.   if h1=0
  170.     then h1:=12
  171.     else if h1>12
  172.       then h1:=h1-12;
  173.   ms:=strr(dt.min);
  174.   if dt.min<10 then ms:='0'+ms;
  175.   timestr:=strr(h1)+':'+ms+' '+ampmstr[dt.hour>11]
  176. end;
  177.  
  178. function datestr (time:longint):sstr;
  179. var dt:datetime;
  180. begin
  181.   unpacktime (time,dt);
  182.   datestr:=strr(dt.month)+'/'+strr(dt.day)+'/'+strr(dt.year-1900)
  183. end;
  184.  
  185. function timepart (time:longint):longint;
  186. begin
  187.   timepart:=time and $0000ffff;
  188. end;
  189.  
  190. function datepart (time:longint):longint;
  191. begin
  192.   datepart:=time and $ffff0000;
  193. end;
  194.  
  195. procedure cleardatetime (var dt:datetime);
  196. begin
  197.   unpacktime (0,dt)
  198. end;
  199.  
  200. function timeval (q:sstr):longint;
  201. var h1,t:word;
  202.     k:char;
  203.     dt:datetime;
  204. begin
  205.   cleardatetime (dt);
  206.   parse3 (q,h1,dt.min,t);
  207.   k:=upcase(q[length(q)-1]);
  208.   if h1 in [1..11]
  209.     then
  210.       begin
  211.         dt.hour:=h1;
  212.         if k='P' then dt.hour:=dt.hour+12
  213.       end
  214.     else
  215.       if k='P'
  216.         then dt.hour:=12
  217.         else dt.hour:=0;
  218.         timeval:=(dt.hour*60)+(dt.min);
  219.   {timeval:=timepart(packtime(dt))}
  220. end;
  221.  
  222. function dateval (q:sstr):longint;
  223. var dt:datetime;
  224. begin
  225.   cleardatetime (dt);
  226.   parse3 (q,dt.month,dt.day,dt.year);
  227.   if dt.year<100 then dt.year:=dt.year+1900;
  228.   dateval:=datepart(packtime(dt))
  229. end;
  230.  
  231. function upstring (s:anystr):anystr;
  232. var cnt:integer;
  233. begin
  234.   for cnt:=1 to length(s) do s[cnt]:=upcase(s[cnt]);
  235.   upstring:=s
  236. end;
  237.  
  238. function match (s1,s2:anystr):boolean;
  239. var cnt:integer;
  240. begin
  241.   match:=false;
  242.   if length(s1)<>length(s2) then exit;
  243.   for cnt:=1 to length(s1) do
  244.     if upcase(s1[cnt])<>upcase(s2[cnt])
  245.       then exit;
  246.   match:=true
  247. end;
  248.  
  249. function devicename (name:lstr):boolean;
  250. var f:file;
  251.     n:integer absolute f;
  252.     r:registers;
  253. begin
  254.   devicename:=false;
  255.   assign (f,name);
  256.   reset (f);
  257.   if ioresult<>0 then exit;
  258.   r.bx:=n;
  259.   r.ax:=$4400;
  260.   intr ($21,r);
  261.   devicename:=(r.dx and 128)=128;
  262.   close (f)
  263. end;
  264.  
  265. function exist (n:lstr):boolean;
  266. var f:file;
  267.     i:integer;
  268. begin
  269.   assign (f,n);
  270.   reset (f);
  271.   i:=ioresult;
  272.   exist:=i=0;
  273.   close (f);
  274.   i:=ioresult
  275. end;
  276.  
  277. procedure appendfile (name:lstr; var q:text);
  278. var n:integer;
  279.     b:boolean;
  280.     f:file of char;
  281. begin
  282.   close (q);
  283.   n:=ioresult;
  284.   assign (q,name);
  285.   assign (f,name);
  286.   reset (f);
  287.   b:=(ioresult<>0) or (filesize(f)=0);
  288.   close (f);
  289.   n:=ioresult;
  290.   if b
  291.     then rewrite (q)
  292.     else append (q)
  293. end;
  294.  
  295. procedure addexitproc (p:pointer);
  296. begin
  297.   inc (exitstackptr);
  298.   if exitstackptr>maxexitprocs then begin
  299.     writeln ('Too many exit procedures');
  300.     halt (255)
  301.   end else begin
  302.     exitstack[exitstackptr]:=exitproc;
  303.     exitproc:=p
  304.   end
  305. end;
  306.  
  307. procedure doneexitproc;
  308. begin
  309.   exitproc:=exitstack[exitstackptr];
  310.   dec (exitstackptr)
  311. end;
  312.  
  313. begin
  314.   exitstackptr:=0
  315. end.
  316.